(module test-types mzscheme
  (require "../src/types/types.scm" "../src/types/type-sugar.scm"
           (planet "test.ss" ("schematics" "schemeunit.plt" 2)))
  
  ;; macro for defining tests on the type sugar
  (define-syntax (test-parse stx)
    (syntax-case stx (=>)
      ((_ ty => expected)
       #'(test-equal? (format "~S" 'ty)
                      (type-sugar (syntax ty))
                      expected))))
  
  ;; macro for defining tests on the weaker than function that uses the
  ;; the two types (before macro expansion) to generate the test case name
  (define-syntax test-wt
    (syntax-rules (=>)
      ((_ (ty1 ...) (ty2 ...) => expected)
       (test-equal? (format "~S" (list (list 'ty1 ...) '<:
                                       (list 'ty2 ...)))
                    (weaker-than (parse-type ty1 ...) (parse-type ty2 ...))
                    expected))))
  
  ;; macro for defining tests on the lattice operations
  (define-syntax test-lattice-op
    (syntax-rules (=>)
      ((_ op (ty1 ...) (ty2 ...) => (expected ...))
       (test-equal? (format "~S" (list (list 'ty1 ...) 'op
                                      (list 'ty2 ...)))
                   (op (parse-type ty1 ...) (parse-type ty2 ...))
                   (parse-type expected ...)))))

  (provide type-tests)
  (define type-tests
    (test-suite "Type System Tests"
       (test-suite "Parsing Unit Tests"))))
          ;(test-parse (int) => (make-ty-app (make-tycon-int) (list)))
          ;(test-parse (list num) =>
          ;             (make-ty-app (make-tycon-list)
          ;                          (list (make-ty-app (make-tycon-num) (list)))))
          ;(test-parse (tuple int bool) =>
          ;            (make-ty-app (make-tycon-tuple)
          ;                         (list (make-ty-app (make-tycon-int)  (list))
          ;                               (make-ty-app (make-tycon-bool) (list)))))
          ;(test-parse ('a) => (list (make-ty-var 'a)))
          ;(test-parse ('A) => (list (make-ty-var-vector 'A)))
          ;(test-parse (-> (int int) bool) =>
          ;            (make-ty-app
          ;             (make-tycon-pure-arrow)
          ;             (list
          ;              (list (make-ty-app (make-tycon-int) (list))
          ;                    (make-ty-app (make-tycon-int) (list)))
          ;              (list (make-ty-app (make-tycon-bool) (list))))))
          ;(test-parse (~> (int bool) int) =>
          ;            (make-ty-app
          ;             (make-tycon-impure-arrow)
          ;             (list
          ;              (list (make-ty-app (make-tycon-int) (list))
          ;                    (make-ty-app (make-tycon-bool) (list)))
          ;              (list (make-ty-app (make-tycon-int) (list))))))
          ;(test-parse (~> (-> (int bool) int) int) =>
          ;            (make-ty-app
          ;             (make-tycon-impure-arrow)
          ;             (list
          ;              (list (make-ty-app
          ;                     (make-tycon-pure-arrow)
          ;                     (list
          ;                      (list (make-ty-app (make-tycon-int) (list))
          ;                            (make-ty-app (make-tycon-bool) (list)))
          ;                      (list (make-ty-app (make-tycon-int) (list))))))
          ;              (list (make-ty-app (make-tycon-int) (list))))))))))
                   #|
          (test-parse "Zero-Arity Without-Parens" (parse-type int)    
                       (make-ty-app (make-tycon-int) (list)))
          (test-parse "One-Arity w/o Parens" (parse-type (list num))
                       (make-ty-app (make-tycon-list)
                                    (list (make-ty-app (make-tycon-num) (list)))))
          (test-parse "Tuple" (parse-type (tuple int bool))
                       (make-ty-app (make-tycon-tuple)
                                     (list (make-ty-app (make-tycon-int)  (list))
                                           (make-ty-app (make-tycon-bool) (list)))))
          (test-parse "Type Variables" (parse-type 'a) (make-ty-var 'a))
          (test-parse "Type Vectors" (parse-type 'A) (make-ty-var-vector 'A))
          (test-parse "Pure Arrow" (parse-type (-> (int int) bool))
                       (make-ty-app
                        (make-tycon-pure-arrow)
                        (list
                         (make-ty-list (list (make-ty-app (make-tycon-int) (list))
                                             (make-ty-app (make-tycon-int) (list))))
                         (make-ty-app (make-tycon-bool) (list)))))
          (test-parse "Impure Arrow" (parse-type (~> (int bool) int))
                       (make-ty-app
                        (make-tycon-impure-arrow)
                        (list
                         (make-ty-list (list (make-ty-app (make-tycon-int) (list))
                                             (make-ty-app (make-tycon-bool) (list))))
                         (make-ty-app (make-tycon-int) (list)))))
          (test-parse "Nested Arrows" (parse-type (~> (-> (int bool) int) int))
                       (make-ty-app
                        (make-tycon-impure-arrow)
                        (list
                         (make-ty-app
                          (make-tycon-pure-arrow)
                          (list
                           (make-ty-list (list (make-ty-app (make-tycon-int) (list))
                                               (make-ty-app (make-tycon-bool) (list))))
                           (make-ty-app (make-tycon-int) (list))))
                         (make-ty-app (make-tycon-int) (list)))))))))

       (test-suite "Weaker Than"
         (test-wt (int)  (num) => #t)
         (test-wt (int)  (int) => #t)
         (test-wt (num)  (int) => #f)
         (test-wt (bool) (num) => #t)
         (test-wt (int) (bool) => #f)
         (test-wt (int -> int) (num -> num) => #f)
         (test-wt (num -> int) (int -> num) => #t)
         (test-wt (int -> num) (int -> int) => #f)
         (test-wt (num -> int) (num -> num) => #t)
         (test-wt (int -> int) (int -> num) => #t)
         (test-wt (int -> int) (num ~> num) => #f)
         (test-wt (num -> int) (int ~> num) => #t)
         (test-wt (num ~> int) (int -> num) => #f)
         (test-wt (num ~> int) (int ~> num) => #t))
       (test-suite "Join & Meet"
         (test-lattice-op join (int) (num) => (num))
         (test-lattice-op meet (bool) (num) => (bool))
         (test-lattice-op join (int) (bool) => (num))
         (test-lattice-op meet (bool) (int) => (bot))
         (test-lattice-op meet (int -> int) (num -> num) => (num -> int))
         (test-lattice-op join (int -> int) (num -> num) => (int -> num))
         (test-lattice-op meet (int -> int) (num ~> num) => (num ~> int))
         (test-lattice-op join (int -> int) (num ~> num) => (int -> num))
         (test-lattice-op meet (int ~> int) (num ~> num) => (num ~> int))
         (test-lattice-op join (int ~> int) (num ~> num) => (int ~> num))
         (test-lattice-op meet ((int -> int) -> int) ((num -> num) -> num) 
                               => ((int -> num) -> int))
         ))))|#